;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
;;  distribution terms for this software are covered by the Eclipse Public
;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
;;  be found in the file epl-v10.html at the root of this distribution.  By
;;  using this software in any fashion, you are agreeing to be bound by the
;;  terms of this license.  You must not remove this notice, or any other,
;;  from this software.
;;
;;  negation.clj
;;
;;  A Clojure implementation of Datalog -- Stratified Negation
;;
;;  straszheimjeffrey (gmail)
;;  Created 8 Feburary 2009


(ns clojure.datalog.negation
  (:use clojure.datalog.eval)
  (:use clojure.datalog.rules)
  (:use clojure.datalog.util)
  (:use clojure.contrib.def)
  (:use [clojure.set :only (union intersection difference)])
  (:use [clojure.contrib.except :only (throwf)]))


;;; Relation elements

(defstruct relation-element
  :relation
  :rules
  :dependent-positive
  :dependent-negative
  :priority)

(defn- make-relation-element
  [rules relation]
  (let [r (filter #(= (rule-relation %) relation) rules)
        p (reduce union #{} (map rule-dependent-relations-positive r))
        n (reduce union #{} (map rule-dependent-relations-negative r))]
    (struct-map relation-element
      :relation relation
      :rules r
      :dependent-positive p
      :dependent-negative n
      :priority 0)))

(defn- print-relation-element
  [el]
  (println)
  (println :relation (:relation el))
  (println :rules)
  (doseq [rule (:rules el)]
    (println (display-logic-rule rule)))
  (println :dependent-positive (:dependent-positive el))
  (println :dependent-negative (:dependent-negative el))
  (println :priority (:priority el)))

(defn- make-elements
  "Given a collection of rules, return a collection of relation
   elements"
  [rules]
  (let [relations (set (map rule-relation rules))]
    (set (map (partial make-relation-element rules) relations))))


;;; Dependency graphs

(defn- stratified-relations-graph
  [els]
  (struct-map directed-graph
    :nodes els
    :get-keys (fn [el] (hash-set (:relation el)))
    :get-neighbors #(union (:dependent-positive %) (:dependent-negative %))))

(defn- new-element
  [element dependents]
  (let [adjusted (disj dependents element)]
    (assoc element
      :priority
      (apply max 0 (for [d adjusted]
                     (cond
                      ((:dependent-positive element) (:relation d)) (:priority d)
                      ((:dependent-negative element) (:relation d)) (inc (:priority d))
                      :otherwise (throwf "Bad dependent in relation element")))))))
  
(defn- compute-dependencies
  "Return a vec with the elements arrange by dependency groups.  Those
   at index 1 depend on those at index 0, those at 2 depend on those
   at 1, and so on."
  [elements]
  (try
   (let [level :priority
         with-levels (build-dependency-levels ; fixed point computation
                      (stratified-relations-graph elements)
                      level
                      new-element)]
     (build-dependency-array (:nodes with-levels) level))
   (catch Exception e
     (if (.contains (.toString e) "Fixed point overflow") ; I know :(
       (throwf "Rules contain unstratified negation")
       (throw e)))))


;;; Work plan

(defn build-work-plan
  "Given a set of rules, return a work plan that can execute them.
   This only needs to be done once for a given set of rules."
  [rules]
  (let [stratified (compute-dependencies (make-elements rules))]
    (for [level stratified]
      (let [rules (reduce concat [] (map :rules level))]
        (construct-prioritized-work-set rules)))))

(defn run-work-plan
  "Given a work plan, and a database, run the work plan against the database,
   returning a new database."
  [work-plan database]
  (reduce (fn [database els] (run-work-elements els database))
          database
          work-plan))
  

(comment

(def test-data
     {
      :employees
      #{
        { :id 1 :name "Sally" :position :boss              :supervisor nil :salary 100000 }
        { :id 2 :name "Fred"  :position :accountant        :supervisor 1   :salary 90000  }
        { :id 3 :name "Janet" :position :accountant        :supervisor 2   :salary 75000  }
        { :id 4 :name "Mike"  :position :senior-programmer :supervisor 1   :salary 80000  }
        { :id 5 :name "Sue"   :position :programmer        :supervisor 4   :salary 65000  }
        { :id 6 :name "Jorge" :position :technition        :supervisor 4   :salary 60000  }
        { :id 7 :name "Jack"  :position :sales             :supervisor 1   :salary 77000  }
        { :id 8 :name "Jan"   :position :sales             :supervisor 7   :salary 65000  }
        { :id 9 :name "Becky" :position :project-manager   :supervisor 1   :salary 60000  }}
      :jobs
      #{
        { :id :payroll            :name "Payroll"              }
        { :id :accounting         :name "Accounting"           }
        { :id :software-dev       :name "Software Development" }
        { :id :computer-support   :name "Computer Support"     }
        { :id :server-support     :name "Server Support"       }
        { :id :sales              :name "Sales"                }
        { :id :project-management :name "Project Management"   }}
      :main-job
      #{
        { :empl-id 2 :job-id :accounting         }
        { :empl-id 3 :job-id :accounting         }
        { :empl-id 4 :job-id :software-dev       }
        { :empl-id 5 :job-id :software-dev       }
        { :empl-id 6 :job-id :server-support     }
        { :empl-id 7 :job-id :sales              }
        { :empl-id 8 :job-id :sales              }
        { :empl-id 9 :job-id :project-management }}})
        
(def test-rules
     [(logic-rule (:outranked-by :id ?x :super ?y) - (:employees :id ?x :supervisor ?y))

      (logic-rule (:outranked-by :id ?x :super ?y) -
                    (:outranked-by :id ?x :super ?z)
                    (:outranked-by :id ?z :super ?y))

      (logic-rule (:outranked-names :name ?x :super-name ?y) -
                    (:outranked-by :id ?u :super ?v)
                    (:employees :name ?x :id ?u)
                    (:employees :name ?y :id ?v))

      (logic-rule (:can-do-job :empl-id ?x :job-id ?y) - (:main-job :empl-id ?x :job-id ?y))

      (logic-rule (:can-do-job :empl-id ?x :job-id :computer-support) -
                     (:can-do-job :empl-id ?x :job-id :software-dev))

      (logic-rule (:can-do-job :empl-id ?x :job-id :computer-support) -
                     (:can-do-job :empl-id ?x :job-id :server-support))

      (logic-rule (:can-do-job :empl-id ?x :job-id :payroll) -
                     (:can-do-job :empl-id ?x :job-id :accounting))

      (logic-rule (:can-do-job :empl-id ?x :job-id ?y) -
                     (:employees :position :boss :id ?x)
                     (:jobs :id ?y)
                     (not! :hard-job :id ?y))

      (logic-rule (:hard-job :id :software-dev) - )
      (logic-rule (:hard-job :id :server-support) - )

      (logic-rule (:by-name :employee ?x :job ?y) -
                     (:employees :name ?x :id ?empl-id)
                     (:jobs      :name ?y :id ?job-id)
                     (:can-do-job :empl-id ?empl-id :job-id ?job-id))

      (logic-rule (:bosses-work :job-id ?x) - (:by-name :employee ?y :job ?x)
                                              (:employees :name ?y :position :boss))

      (logic-rule (:well-paid :name ?x :salary ?y) - (:employees :name ?x :salary ?y) (if > ?y 75000))
])

(def test-plan (build-work-plan test-rules))
(def results (run-work-plan test-plan test-data))
(:bosses-work results)
(:well-paid results)

)

;; End of file

